home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
BMUG Revelations
/
BMUG Revelations.toast
/
Programming
/
Programming Languages
/
Yerk 3.64
/
Module source
/
Install
< prev
next >
Wrap
Text File
|
1993-07-25
|
17KB
|
532 lines
\ 12/30/81 cbd Version 1
\ 2/04/86 cdn Moved in FinalSave ; added "Max Heap" button
\ 7/15/86 cdn Exported
\ 7/17/86 cdn Added iBNDL & AddModRes
\ 7/28/86 cdn Added saveAppl
\ 6/07/91 rfl modified for system 7 version. Works the same way as old one,
\ but dictionary size refers to amount available above here.
\ 6/14/91 rfl removed maxdict from module since is defined past floating point
\ Instead, use msize !
\ Dictionary size now means size past 'here', the current dictionary size.
\ 7/20/91 rfl remove clobber for my use
\ 10/17/91 rfl easier to use for install process now. New dialog, better mem management
\ 11/15/91 rfl added readFP to saveNuc
\ 5/17/92 rfl fixed cancel cosmetic problem
\ 5/18/93 rfl application no longer uses Yerk file as base; it creates
\ a completely new file, copying resources out of Yerk, leaving Yerk untouched.
\ 5/23/93 rfl added // sarray
\ 5/30/93 rfl added various frontend words so module will work with both yerk.com
\ and yerkFP.com. Also changed ' (ticks) to 'c >body
\ 7/25/93 rfl removed delete switches and added clobber switch; removed extra ctlwin code
Decimal
:Module iMod
Decimal
// ctl
// ctlwind
// vscroll
// alert
\ This is a copy of the Alert" code from "AlertQ" and "Imports"
\ It is duplicated here so that ALERTMOD is not required on the install disk
\ alert support
\ 1/01/85 cbd Version 1
\ 9/05/85 cdn Added disp: method
\ 8/22/86 cdn Renumbered alert types to correspond with IM
0 Variable tALRT here +base tALRT !
100 w, 51 w, 191 w, 462 w, 0 w, $ 7fff w,
0 Variable tDITL here +base tDITL !
2 w, \ # items-1
0, 58 w, 177 w, 80 w, 234 w, 4 c, 2 c, 'type ..OK w,
0, 60 w, 355 w, 81 w, 393 w, 136 c, 4 c, 'type 0000 ,
0, 10 w, 76 w, 42 w, 393 w, 136 c,
3 Alert Alrt
\ Display alert using message saved in-line
: (Al") { RC type -- }
RC
IF \ build ALRT from scratch
12 newHandle
dup 'type ALRT word0 nullOSstr call AddResource
>ptr tALRT 4+ swap 12 cMove
\ build DITL from scratch
R dup c@ align 50 + newHandle
dup 'type DITL word0 nullOSstr call AddResource
tDITL 36 + 4 blanks
RC s->d swap over dabs <# #s sign #> tDITL 36 + swap 4 min cMove
>ptr tDITL 4+ over 49 cMove
49 + over c@ 1+ cMove
arrowcurs
0 type disp: alrt
0 GetRes ALRT dup call RmveResource call ReleaseResource
0 GetRes DITL dup call RmveResource call ReleaseResource
type 0 max 3 min exec: Aact
THEN
R c@ 1+ align R> + >R
;
\ ( RC type : str" -- ) Compile conditional alert box
: Alert"
?comp Compile (al") word" c@ 1+ Align allot
; Immediate
: copyRsrc { id type \ hndl -- hndl } id type (getres) -> hndl
hndl call detachResource
hndl type id makeint nullOSStr call addResource hndl ;
0 Value curStack
0 Value curDict
8400 constant minHeap \ can't set heap to less than this amt
52 constant stVal \ 52 from location in nuc
\ ( handle -- handle ) mark the resource for update to disk
: ChR dup call ChangedResource ;
: unlockSeg 2 getres CODE unlock ;
: lockSeg 2 getres CODE lock ;
: readFP " fpInit" sFind
IF 2drop 5 'type CODE (getres) dup >ptr 'f> rot 0 swap call SizeResource cmove
THEN ;
2 constant IsApplication
\ Save the current Yerk Code resource
: saveCode2
2 GetRes CODE call ChangedResource \ Mark nucleus for writing
word0 call ResError i->l 0 Alert" nucleus write error"
fFcb clrFcb
tib 410 erase \ tib, num output, pad, aRegn
\ 0 msize !
cflush call ExitToShell ; \ Causes nuc changes to be written, but first flush cache
\ Save CODE 2 resource without dictionary
: saveNuc
'c .s >body nfa dup 8 ! 12 ! \ assumes .s is last definition in nuc
\ store into initLast and initFenc (lastdef)
16 24 erase \ clear user initialization data
\ but keep whatever is in msize
'c (key) 'c abort 20 + ! \ use primitive (key) again
\ assumes abort is original abort (16 offset)
readFP
begin-dp @ 2- (codezone) saveCode2 ;
\ Save CODE 2 resource with dictionary; eliminating loaduser code
: saveAppl
IsApplication 1 getres CODE >ptr 6 + c! \ flag loader code that this is an appl.
1 'type CODE copyRsrc dup w 48 call setResAttrs chr call WriteResource
word0 call ResError i->l 0 Alert" code 1 write error"
0 'type CODE copyRsrc dup w 32 call setResAttrs chr call WriteResource
word0 call ResError i->l 0 Alert" code 0 write error"
readFP
\ $ 4e714e71 noload ! \ a nono, patch code, but we will flush the cache
cflush
0 ' iMod 8+ ! \ protect install code from purge
purge \ purge all modules
0 -> path
fwind -> actw \ set active window ptr to fwind, not iwind
$ 10000 here curDict + - 0 max allot \ meet 64K boundary requirement
here unlockSeg (codezone) lockSeg
2 'type CODE copyRsrc w 48 call setResAttrs saveCode2 ; \ save just enough
\ fetch starting stack headroom for this nucleus
: @stack stVal @ negate ;
: !stack curStack negate stVal ! ;
\ fetch starting heap size for this nucleus
: @heap s0 @stack - begin-dp @ - msize @ - ;
\ determine amount of heap available for current configuration
: curHeap @heap @stack curStack - + room curDict - + ;
\ set nucleus minimum heap value - no longer necessary
: !heap ; \ curHeap mpatch ! ;
Decimal
: Closer close: caller ;
Int theItem
Var itemHandle
Int itemType
0 value rtm
:CLASS Dialog <Super X-Array
Int Resid
Var dialPtr
Var procPtr
Int boldItem
\ ( -- )
:M CLOSE: get: dialPtr call DisposDialog ;M
:M SET: get: dialPtr call setPort ;M
\ ( item# -- hndl ) get handle for item#
:M HANDLE: { item# -- hndl } get: dialPtr item# makeInt
abs: itemType abs: itemHandle abs: tempRect
call GetDItem get: itemHandle ;M
\ draws the frame around the hilit item
:M FRAME: get: boldItem -dup
IF savePort get: dialPtr call SetPort 3 3 pack call PenSize
handle: self drop -4 -4 inset: tempRect
abs: tempRect 16 16 pack call FrameRoundRect call penNormal restPort
THEN ;M
\ ( -- ) create dialog from resID
:M GETNEW: 0 int: resid 0 -1 call GetNewDialog put: dialPtr
frame: self ;M
:M SHOW: get: dialPtr call showWindow frame: self ;M
\ ( cfa -- ) set dialog proc
:M SETPROC: >body put: procPtr ;M
\ ( -- ) display as modal dialog
:M MODAL:
BEGIN
get: procPtr dup IF +base THEN abs: theItem call ModalDialog
get: theItem ( 1-) exec: super
rtm
WHILE
0 -> rtm \ iterate every time ReturnToModal is executed
REPEAT
;M
\ ( act0 ... actN -- ) set the dialog's action handlers starting at element 1
:M ACTIONS: ?ixobj limit 1- 0
DO limit i- 1- (^elem) !
LOOP ;M
\ ( val item# -- )
:M PUT: handle: self swap makeInt call SetCtlValue ;M
\ ( item# -- val ) get value for an item#
:M GET: handle: self >R word0 R>
call GetCtlValue word0 ;M \ added word0 cbd 7/17/85
\ ( resID -- ) Associate object with its resource
:M INIT: put: resID ;M
\ ( item# -- ) Causes bold outline of the specified item
:M HILITE: put: boldItem ;M
\ ( item# -- addr len ) return a text item's text
:M GETTEXT: handle: self buf255 +base get: ItemType dup 24 and
IF drop call GetIText
ELSE 4 and
IF call GetCTitle
ELSE 2drop 0 buf255 c! \ user item has no text
THEN
THEN
buf255 count ;M
\ ( addr len item# -- ) store an item's text
:M PUTTEXT: { addr len item# -- } item# handle: self
addr len str255 get: ItemType dup 24 and
IF drop call SetIText
ELSE 4 and
IF call SetCTitle
ELSE 2drop \ user item has no text
THEN
THEN ;M
\ ( start end item# ) set selection range for text item
:M SETSELECT: { start end item# -- } get: dialPtr
item# makeInt start end pack call SeliText ;M
\ ( -- ) force drawing of dialog before going to modal:
:M DRAW: get: dialPtr call DrawDialog ;M
\ set user item into dialog; userItem must start with rectangle data
:M SETUSERITEM: { userItem -- }
get: dialPtr getParms: userItem abs: userItem call setDItem ;M
\ ( -- ) Initialize default handlers to close the dialog box
:M CLASSINIT: limit 0 DO 'c closer i to: self LOOP ;M
;CLASS
\ signal modal method to re-enter ModalDialog
: ReturnToModal
1 -> rtm ;
\ Toggle the check box or radio button
: togItem
get: theItem 1 over get: caller - swap put: caller
ReturnToModal
;
\ ( addr0 len0 addr1 len1 addr2 len2 addr3 len3 -- ) Substitute Dialog text
: ParamText { \ p1 p2 p3 -- }
str255 dup -> p3 -base count +
>str255 dup -> p2 -base count +
>str255 dup -> p1 -base count +
>str255 p1 p2 p3 call ParamText
;
16 dialog iDlg
111 init: iDlg
1 hilite: iDlg
\ ( addr1 len1 addr2 len2 -- ) Install informatory message
: iMsg " " " " ParamText draw: iDlg ;
\ need to load this because sarray is in different
\ locations in yerk.com and yerkFP.com
// pathList
forget getptxt
// listman
\ install a resource type module
: AddModRes { mdef arg \ resID -- }
mdef @ modCode <> IF exit THEN
mdef indexOf: nMods IF drop ELSE exit THEN
mdef >name n>count binName name: fFcb
openReadOnly: fFcb IF exit THEN
mdef 12 + dispose
" Module:" getName: fFcb iMsg
size: fFcb align new: mHndl \ Create a new handle for this module
ptr: mHndl size: mHndl read: fFcb 0 Alert" Module read failed"
close: fFcb drop
word0 'type CODE call UniqueID i->l -> resID
get: mHndl dup 'type CODE resID makeInt \ Create new Module resource
mdef >name n>count str255 call AddResource
dup w 16 call SetResAttrs \ mark resource locked
ChR call WriteResource \ write it to application file
word0 call ResError i->l 0 Alert" Module rsrc write failed. Check disk space or try Delete modules option."
resID mdef 22 + w! \ store module resID
\ 14 get: iDlg IF delete: fFcb drop THEN \ free up disk space?
;
\ ( item# -- )
: invWord errbeep 0 $ ffff rot setSelect: iDlg ReturnToModal ;
\ ( -- True ) validate quit & abort words; if bad return to modal
: okBtn \ { \ qv -- }
10 getText: iDlg sFind 0= IF 10 invWord exit THEN
drop cfa -> quitVec
11 getText: iDlg sFind 0= IF 11 invWord exit THEN
drop cfa -> abortVec
12 getText: iDlg sFind 0= IF 12 invWord exit THEN
drop cfa -> objInit
True
;
11 'cfas okBtn False null null null null null null null null null
4 'cfas null togItem togItem togItem
actions: iDlg
Int apRefNum
Var apParam
String applName
: getR
128 GetRes BNDL >ptr @ sp@ 4 3 putText: iDlg
0 swap (GetRes) >ptr count 4 putText: iDlg
buf255 +base abs: apRefNum abs: apParam call GetAppParms
buf255 count 2dup 5 putText: iDlg put: applName
129 GetRes FREF >ptr @ sp@ 4 6 putText: iDlg drop
130 GetRes FREF >ptr @ sp@ 4 7 putText: iDlg drop
131 GetRes FREF >ptr @ sp@ 4 8 putText: iDlg drop
132 GetRes FREF >ptr @ sp@ 4 9 putText: iDlg drop
;
\ ( addr len -- (addr) ) fetch 1st four bytes on an odd byte, pad with blanks
: drop@ >R sp@ $ 20202020 rot rot R> 4 min cMove ;
: putR
128 'type BNDL copyRsrc dup call writeResource put: mHndl
3 getText: iDlg drop@ dup ptr: mHndl ! ( newSig to BNDL)
get: mHndl call changedResource
get: applName name: fFcb 'type APPL over set: fFcb
4 getText: iDlg dup 1+ align new: mHndl ( newSig addr len )
str255 -base ptr: mHndl over c@ 1+ cMove ( newSig )
get: mHndl swap word0 nullOSstr call AddResource get: mHndl call writeResource
10 5 DO i getText: iDlg drop@ 129 getres FREF >ptr !
123 i+ 'type FREF copyRsrc dup w 32 call setResAttrs
chr call writeResource
LOOP
13 get: iDlg 8 << 256 getres WIND >ptr 10 + w!
256 'type WIND copyRsrc call writeResource
133 128 DO i 'type ICN# copyRsrc dup
w 32 call setResAttrs chr
call writeResource
LOOP
1 'type vers copyRsrc call writeResource
-1 'type SIZE copyRsrc call writeResource
;
\ set dictionary heap and stack to selected values
\ for apps, the old dictionary had become the new nucleus
: setMem here curDict + ( begin-dp @ -) msize ! ( !heap) !stack
here 4+ msize 12 - ! \ store new initdp, leave 4 bytes room at end
latest 8 ! ; \ store last definition
\ clobber name fields in nucleus - can't clobber in entire dictionary
\ without leaving :proc definitions intact because of the way initProcs
\ searches the dictionary.
: killName n>count 1 fill ;
: clobber 'c cold >body nfa
BEGIN dup killName pfa lfa @ dup 'c fWind >body nfa =
UNTIL drop ;
\ This will clobber the entire dictionary. This could be fatal if your code
\ does a search of the dictionary at runtime. For that reason, this code
\ is not used here.
\ : (clobber) ( mycfa parm --) drop >body nfa killName ;
\ : clobber 'c (clobber) 0 trav ;
1 Value icurs
: iBNDL
'c bye 0 to: Aact \ Alert action
new: applName
getnew: iDlg
getR
" NULW" 10 putText: iDlg
" fpInit" sFind IF 2drop " CLEANFLOAT" ELSE " CLEAN2" THEN
11 putText: iDlg
latest n>count 12 putText: iDlg \ ******
0 $ ffff 5 setSelect: iDlg
modal: iDlg
IF watchcurs
5 getText: iDlg 2dup put: applName \ get new filename
str255 call createResFile \ create new file by that name
5 getText: iDlg name: fFcb \ want to set finder flags
getfileinfo: ffcb 0 Alert" getfileinfo error"
ffcb 40 + w@ $ 2100 or ffcb 40 + w! \ set bndl bit and init bit
ffcb fcall setfileinfo 0 Alert" setfileinfo error"
lock: applName
word0 get: applName str255 unlock: applName
call openResFile i->l 0< not
IF putR \ store new resources
" Installing ^0 ^1" 23 putText: iDlg
'c AddModRes 0 trav \ Convert modules on this disk into resources
" Dictionary" " " iMsg
init: loadFile
\ 15 get: iDlg IF get: imageName name: fFcb delete: fFcb drop THEN
14 get: iDlg IF clobber THEN \ fsecure nucleus
setMem saveAppl \ save application
ELSE close: iDlg 1 1 alert" couldn't open appl resource file" abort
THEN
THEN
release: applName
close: iDlg
'c IMOD mUnlock 'c abort 0 to: Aact icurs -> curs set: fwind become quit ;
vScroll vs1
vScroll vs2
Control saveBtn
Control instBtn
Control canBtn
Control heapBtn
Control mxSt radioID init: mxSt
Control miSt radioID init: miSt
Control mxDi radioID init: mxDi
Control miDi radioID init: miDi
\ Rectangles for formatting screen
Rect stRect \ stack headroom
20 20 170 40 put: stRect
Rect hpRect \ heap start size
20 45 170 65 put: hpRect
Rect diRect \ Dictionary headroom
20 70 170 90 put: diRect
rect wRect
100 40 400 170 put: wRect
\ get current limits for stack and dict based on minHeap
: maxiStack curStack curHeap minHeap - + ;
: maxiDict curDict curHeap minHeap - + ;
9000 value minStack
128 value minDict
\ print number in rect
: .Val { n theRect -- } tempRect =: theRect
4 4 inset: tempRect 100 putTopX: tempRect clear: tempRect
104 getboty: tempRect gotoxy n 7 .r ;
: .vs1 curStack stRect .val curHeap hpRect .val ;
: .vs2 curDict diRect .val curHeap hpRect .val ;
: drawIwind draw: stRect draw: hpRect draw: diRect
2 tmode 0 tfont 12 tsize
24 36 gotoxy ." Stack:"
24 61 gotoxy ." Heap:"
24 86 gotoxy ." Dictionary:" .vs1 .vs2 ;
\ Define the Install utility window
ctlWind iWind
4 'cfas null null drawIwind null actions: iWind
\ listen to mouse and drop keys
: listener BEGIN key drop AGAIN ;
\ Create new window, controls
: Install
wRect " " dlgWind True False new: iWind
180 15 33 iWind new: vs1 180 65 33 iWind new: vs2
2000 32000 putRange: vs1 0 8000 putRange: vs2
4000 dup put: vs1 put: vs2
@stack -> curStack room -> curDict
197 14 " ++" iWind new: mxSt
197 30 " --" iWind new: miSt
197 64 " ++" iWind new: mxDi
197 80 " --" iWind new: miDi
238 20 " Save" iWind new: saveBtn
236 45 " Install" iWind new: instBtn
236 70 " Cancel" iWind new: canBtn
150 105 " Max Heap" iWind new: heapBtn
update: iWind curs -> icurs -curs
Become listener ;
: stDn curStack 8 - minStack max -> curStack .vs1 ;
: stUp curStack 8+ maxiStack min -> curStack .vs1 ;
: diDn curDict 32 - minDict max -> curDict .vs2 ;
: diUp curDict 32 + maxiDict min -> curDict .vs2 ;
5 'cfas stUp stDn null null null actions: vs1
5 'cfas diUp diDn null null null actions: vs2
: config curDict here + begin-dp @ - msize ! ( !heap) !stack saveNuc ;
: wInstall close: iWind buildmodWind ;
: cancel close: iWind 'c IMOD mUnlock icurs -> curs set: fwind become quit ;
: doMxSt curStack 512 + maxiStack min -> curStack .vs1 ;
: doMiSt curStack 512 - minStack max -> curStack .vs1 ;
: doMxDi curDict 8192 + maxiDict min -> curDict .vs2 ;
: doMiDi curDict 8192 - minDict max -> curDict .vs2 ;
: doMxHp minStack -> curStack .vs1 minDict -> curDict .vs2 ;
: buildInstall acceptSelect iBndl ;
'c BuildInstall actions: selectBut
'c config actions: saveBtn
'c wInstall actions: instBtn
'c cancel actions: canBtn
'c doMxSt actions: mxSt
'c doMiSt actions: miSt
'c doMxDi actions: mxDI
'c doMiDi actions: miDi
'c doMxHp actions: heapBtn
;Module